(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

open Logging
open Pycaml
open Python_tools
open XNum  
  
(* One inch in points. *)
let inch = num_of_ints 7227 100
  
(* Badness is a measure of how bad a scaled box looks. *)
let infinite = num_of_int 10000
  
let minus_infinite = num_of_int (-10000)
  
(* |badness <ratio>| calculates the badness of a box from its adjustment ratio. *)
let badness ratio =
  if lt_num ratio (num_of_int (-1))
  then infinite
  else
    round_num
      (abs_num
         (mult_num (mult_num (mult_num (num_of_int 100) ratio) ratio) ratio))
  
(*
   A dimension consists of a base value and the amount it can grow or shrink.
   All values are in units of point.
*)
type dim = {
  d_base           : num;
  d_stretch_factor : num;    (* FIX: Why is this called a 'factor'? *)
  d_stretch_order  : int;
  d_shrink_factor  : num;    (* FIX: Why is this called a 'factor'? *)
  d_shrink_order   : int
} (* with sexp *)

type xdim = {
  xd_base    : num;
  xd_stretch : (num * int) list;
  xd_shrink  : (num * int) list
} (* with sexp *)

let fixed_dim x =
  { d_base = x;
    d_stretch_factor = num_zero;
    d_stretch_order = 0;
    d_shrink_factor = num_zero;
    d_shrink_order = 0 }
  
let dim_zero = fixed_dim num_zero
  
let dim_1pt = fixed_dim num_one
  
let dim_12pt = fixed_dim (num_of_int 12)
  
let dim_fil =
  { d_base = num_zero;
    d_stretch_factor = num_one;
    d_stretch_order = 1;
    d_shrink_factor = num_zero;
    d_shrink_order = 0 }
  
let dim_fill =
  { d_base = num_zero;
    d_stretch_factor = num_one;
    d_stretch_order = 2;
    d_shrink_factor = num_zero;
    d_shrink_order = 0 }
  
let dim_ss =
  { d_base = num_zero;
    d_stretch_factor = num_one;
    d_stretch_order = 1;
    d_shrink_factor = num_one;
    d_shrink_order = 1 }
  
let dim_filneg =
  { d_base = num_zero;
    d_stretch_factor = num_of_int (-1);
    d_stretch_order = 1;
    d_shrink_factor = num_zero;
    d_shrink_order = 0 }
  
let xdim_zero =
  { xd_base = num_zero;
    xd_stretch = [];
    xd_shrink = [] }
  
let dim_stretch d = (d.d_stretch_factor, d.d_stretch_order)
  
let dim_shrink d = (d.d_shrink_factor, d.d_shrink_order)
  
let xdim_stretch d = (* return the first non-zero entry in |xd_stretch| *)
  let rec iter stretch =
    match stretch with
      | [] -> (num_zero, 0)
      | s :: ss -> if not (eq_num (fst s) num_zero) then s else iter ss
  in
    iter d.xd_stretch
  
let xdim_shrink d = (* return the first non-zero entry in |xd_shrink| *)
  let rec iter shrink =
    match shrink with
      | [] -> (num_zero, 0)
      | s :: ss -> if not (eq_num (fst s) num_zero) then s else iter ss
  in
    iter d.xd_shrink
  
(* convert xdim to dim *)
let xdim_to_dim d =
  let (st_f, st_o) = xdim_stretch d in
  let (sh_f, sh_o) = xdim_shrink d in
    { d_base = d.xd_base;
      d_stretch_factor = st_f;
      d_stretch_order = st_o;
      d_shrink_factor = sh_f;
      d_shrink_order = sh_o }
  
(* convert dim to xdim *)
let dim_to_xdim d =
  { xd_base = d.d_base;
    xd_stretch = [(d.d_stretch_factor, d.d_stretch_order)];
    xd_shrink = [(d.d_shrink_factor, d.d_shrink_order)] }
  
let dim_equal d0 d1 =
  d0.d_base = d1.d_base &&
  d0.d_stretch_factor = d1.d_stretch_factor &&
  d0.d_stretch_order = d1.d_stretch_order &&
  d0.d_shrink_factor = d1.d_shrink_factor &&
  d0.d_shrink_order = d1.d_shrink_order
  
let dim_is_zero d =
  d.d_base = num_zero &&
  d.d_stretch_factor = num_zero &&
  d.d_stretch_order = 0 &&
  d.d_shrink_factor = num_zero &&
  d.d_shrink_order = 0
  
let log_dim d =
  (log_num d.d_base;
   log_string "pt";
   if not (eq_num d.d_stretch_factor num_zero)
   then
     (log_string " plus ";
      log_num d.d_stretch_factor;
      if d.d_stretch_order = 0
      then log_string "pt"
      else
        (log_string "fi";
         for i = 1 to d.d_stretch_order do log_string "l" done))
   else ();
   if not (eq_num d.d_shrink_factor num_zero)
   then
     (log_string " minus ";
      log_num d.d_shrink_factor;
      if d.d_shrink_order = 0
      then log_string "pt"
      else
        (log_string "fi";
         for i = 1 to d.d_shrink_order do log_string "l" done))
   else ())
  
(* Routines to add and subtract dimensions. *)
let dim_add d1 d2 =
  let add_order s1 o1 s2 o2 =
    if o1 < o2
    then (s2, o2)
    else if o1 > o2 then (s1, o1) else ((add_num s1 s2), o1) in
  let (st_f, st_o) =
    add_order d1.d_stretch_factor d1.d_stretch_order d2.d_stretch_factor
      d2.d_stretch_order in
  let (sh_f, sh_o) =
    add_order d1.d_shrink_factor d1.d_shrink_order d2.d_shrink_factor
      d2.d_shrink_order
  in
    {
      d_base = add_num d1.d_base d2.d_base;
      d_stretch_factor = st_f;
      d_stretch_order = st_o;
      d_shrink_factor = sh_f;
      d_shrink_order = sh_o;
    }
  
let xdim_add d1 d2 =
  let rec insert_order l (s, o) =
    match l with
    | [] -> [ (s, o) ]
    | (x, y) :: zs ->
        if o > y
        then (s, o) :: l
        else
          if o = y
          then ((add_num s x), o) :: zs
          else (x, y) :: (insert_order zs (s, o)) in
  let rec add_lists l1 l2 =
    match l2 with
    | [] -> l1
    | (s, o) :: xs -> insert_order (add_lists l1 xs) (s, o)
  in
    {
      xd_base = add_num d1.xd_base d2.xd_base;
      xd_stretch = add_lists d1.xd_stretch d2.xd_stretch;
      xd_shrink = add_lists d1.xd_shrink d2.xd_shrink;
    }
  
let xdim_add_dim d1 d2 =
  let rec insert_order l s o =
    match l with
    | [] -> [ (s, o) ]
    | (x, y) :: zs ->
        if o > y
        then (s, o) :: l
        else
          if o = y
          then ((add_num s x), o) :: zs
          else (x, y) :: (insert_order zs s o)
  in
    {
      xd_base = add_num d1.xd_base d2.d_base;
      xd_stretch =
        insert_order d1.xd_stretch d2.d_stretch_factor d2.d_stretch_order;
      xd_shrink =
        insert_order d1.xd_shrink d2.d_shrink_factor d2.d_shrink_order;
    }
  
let dim_neg d =
  {
    d_base = minus_num d.d_base;
    d_stretch_factor = minus_num d.d_stretch_factor;
    d_stretch_order = d.d_stretch_order;
    d_shrink_factor = minus_num d.d_shrink_factor;
    d_shrink_order = d.d_shrink_order;
  }
  
let xdim_neg d =
  let neg_list l = List.map (fun (x, y) -> ((minus_num x), y)) l
  in
    {
      xd_base = minus_num d.xd_base;
      xd_stretch = neg_list d.xd_stretch;
      xd_shrink = neg_list d.xd_shrink;
    }
  
let dim_sub d1 d2 = dim_add d1 (dim_neg d2)
  
let xdim_sub d1 d2 = xdim_add d1 (xdim_neg d2)
  
let xdim_sub_dim d1 d2 = xdim_add_dim d1 (dim_neg d2)
  
let dim_mult factor d =
  { d_base = mult_num factor d.d_base;
    d_stretch_factor = mult_num factor d.d_stretch_factor;
    d_stretch_order = d.d_stretch_order;
    d_shrink_factor = mult_num factor d.d_shrink_factor;
    d_shrink_order = d.d_shrink_order }
  
let xdim_mult factor d =
  let mult_list l = List.map (fun (x, y) -> ((mult_num factor x), y)) l in
    { xd_base = mult_num factor d.xd_base;
      xd_stretch = mult_list d.xd_stretch;
      xd_shrink = mult_list d.xd_shrink }
  
(* maximal and minimal values *)
(*
  |max_extension (<f>, <o>)| returns the maximal increase allowed by <f> and <o>. If it is unlimited
  |infinite| or |-infinite| is returned.
*)
let max_extension (f, o) =
  if o = 0
  then f
  else if ge_num f num_zero then infinite else minus_num infinite
  
(* These functions return the maximal amount the given dimension can be stretched/shrinked. *)
let dim_max_stretch dim = max_extension (dim_stretch dim)
  
let dim_max_shrink dim = max_extension (dim_shrink dim)
  
let xdim_max_stretch dim = max_extension (xdim_stretch dim)
  
let xdim_max_shrink dim = max_extension (xdim_shrink dim)
  
(* The functions below return the maximal and minimal extensions of a given dimension. *)
let max_value base extension =
  if ge_num extension infinite
  then infinite
  else
    if le_num extension (minus_num infinite)
    then minus_num infinite
    else add_num base extension
  
let dim_max_value dim = max_value dim.d_base (dim_max_stretch dim)
  
let dim_min_value dim = max_value dim.d_base (dim_max_shrink dim)
  
let xdim_max_value dim = max_value dim.xd_base (xdim_max_stretch dim)
  
let xdim_min_value dim = max_value dim.xd_base (xdim_max_shrink dim)
  
(*
  |shift_order (<f>, <o>) <delta>| adds <delta> to <f> if <o> is zero. If <f> changes its sign then
  the result is (0, 0).
*)
let shift_order (f, o) delta =
  if o <> 0
  then (f, o)
  else
    (let x = add_num f delta
     in
       if
         ((ge_num f num_zero) && (ge_num x num_zero)) ||
           ((lt_num f num_zero) && (lt_num x num_zero))
       then (x, o)
       else (num_zero, 0))
  
(*
  |dim_shift_base <dim> <delta>| adds <delta> to the base of <dim> without changing the maximal and
  minimal extension of <dim>. The variant |dim_shift_base_upto <dim> <delta>| respects the maximal
  and minimal extensions of <dim>.
*)
let dim_shift_base dim delta =
  let (st_f, st_o) = shift_order (dim_stretch dim) (minus_num delta) in
  let (sh_f, sh_o) = shift_order (dim_shrink dim) delta
  in
    {
      d_base = add_num dim.d_base delta;
      d_stretch_factor = st_f;
      d_stretch_order = st_o;
      d_shrink_factor = sh_f;
      d_shrink_order = sh_o;
    }
  
let dim_shift_base_upto dim delta =
  if ge_num delta num_zero
  then
    if (dim.d_stretch_order = 0) && (lt_num dim.d_stretch_factor delta)
    then dim_shift_base dim dim.d_stretch_factor
    else dim_shift_base dim delta
  else
    if
      (dim.d_shrink_order = 0) &&
        (lt_num dim.d_shrink_factor (minus_num delta))
    then dim_shift_base dim (minus_num dim.d_shrink_factor)
    else dim_shift_base dim delta
  
(*
  |dim_inc_upto <dim> <delta>| increases <dim> by <delta>. If this value is larger than the maximal
  value of <dim> then this maximum is returned. It is assumed that <delta> is non-negative.
*)
let dim_inc_upto dim delta =
  let max_delta = dim_max_stretch dim
  in
    if lt_num max_delta delta
    then dim_shift_base dim max_delta
    else dim_shift_base dim delta
  
(*
  |dim_dec_upto <dim> <delta>| decreases <dim> by <delta>. If this value is smaller than the minimal
  value of <dim> then this minimum is returned. It is assumed that <delta> is non-negative.
*)
let dim_dec_upto dim delta =
  let max_delta = dim_max_shrink dim
  in
    if lt_num max_delta delta
    then dim_shift_base dim (minus_num max_delta)
    else dim_shift_base dim (minus_num delta)
  
(* |dim_resize_upto <dim> <delta>| increases or decreases <dim> by <delta>. *)
let dim_resize_upto dim delta =
  if ge_num delta num_zero
  then dim_inc_upto dim delta
  else dim_dec_upto dim delta
  
(* maximum and minimun of dimensions *)
(*
  |min_factor <f1> <f2>| returns the argument of minimal absolute value. If <f1> and <f2> have
  different signs then 0 is returned. Analogously, |max_factor <f1> <f2>| returns the argument
  of maximal absolute value.
*)
let min_factor f1 f2 =
  if le_num f1 f2
  then
    if ge_num f1 num_zero
    then f1
    else if le_num f2 num_zero then f2 else num_zero
  else
    if ge_num f2 num_zero
    then f2
    else if le_num f1 num_zero then f1 else num_zero
  
let max_factor f1 f2 =
  if le_num f1 f2
  then
    if ge_num f1 num_zero
    then f2
    else if le_num f2 num_zero then f1 else num_zero
  else
    if ge_num f2 num_zero
    then f1
    else if le_num f1 num_zero then f2 else num_zero
  
let min_order (f1, o1) (f2, o2) =
  if o1 < o2
  then (f1, o1)
  else if o2 < o1 then (f2, o2) else ((min_factor f1 f2), o1)
  
let max_order (f1, o1) (f2, o2) =
  if o1 > o2
  then (f1, o1)
  else if o2 > o1 then (f2, o2) else ((max_factor f1 f2), o1)
  
let dim_max d1 d2 =
  if gt_num d1.d_base d2.d_base
  then
    (let delta = sub_num d1.d_base d2.d_base in
     let (st_f, st_o) =
       min_order (dim_stretch d1)
         (shift_order (dim_stretch d2) (minus_num delta)) in
     let (sh_f, sh_o) =
       min_order (dim_shrink d1) (shift_order (dim_shrink d2) delta)
     in
       {
         d_base = d1.d_base;
         d_stretch_factor = st_f;
         d_stretch_order = st_o;
         d_shrink_factor = sh_f;
         d_shrink_order = sh_o;
       })
  else
    (let delta = sub_num d2.d_base d1.d_base in
     let (st_f, st_o) =
       min_order (shift_order (dim_stretch d1) (minus_num delta))
         (dim_stretch d2) in
     let (sh_f, sh_o) =
       min_order (shift_order (dim_shrink d1) delta) (dim_shrink d2)
     in
       {
         d_base = d2.d_base;
         d_stretch_factor = st_f;
         d_stretch_order = st_o;
         d_shrink_factor = sh_f;
         d_shrink_order = sh_o;
       })
  
let dim_min d1 d2 =
  if lt_num d1.d_base d2.d_base
  then
    (let delta = sub_num d1.d_base d2.d_base in
     let (st_f, st_o) =
       min_order (dim_stretch d1)
         (shift_order (dim_stretch d2) (minus_num delta)) in
     let (sh_f, sh_o) =
       min_order (dim_shrink d1) (shift_order (dim_shrink d2) delta)
     in
       {
         d_base = d1.d_base;
         d_stretch_factor = st_f;
         d_stretch_order = st_o;
         d_shrink_factor = sh_f;
         d_shrink_order = sh_o;
       })
  else
    (let delta = sub_num d2.d_base d1.d_base in
     let (st_f, st_o) =
       min_order (shift_order (dim_stretch d1) (minus_num delta))
         (dim_stretch d2) in
     let (sh_f, sh_o) =
       min_order (shift_order (dim_shrink d1) delta) (dim_shrink d2)
     in
       {
         d_base = d2.d_base;
         d_stretch_factor = st_f;
         d_stretch_order = st_o;
         d_shrink_factor = sh_f;
         d_shrink_order = sh_o;
       })
  
let adjustment_ratio dim size =
  let scale (factor, order) delta =
    if delta = num_zero
    then (num_zero, 0)
    else
      if factor = num_zero
      then
        if ge_num delta num_zero
        then (infinite, 0)
        else ((minus_num infinite), 0)
      else ((div_num delta factor), order)
  and b = dim.d_base
  in
    if lt_num size b
    then scale (dim_shrink dim) (sub_num size b)
    else scale (dim_stretch dim) (sub_num size b)
  
let dim_scale_badness (factor, order) =
  if order > 0 then num_zero else badness factor
  
(*
  |dim_scale <dim> (<factor>, <order>)| scales <dim> by <factor> times its strechability/shrinkability,
  provided its stretch/shrink order equals <order>. The variant |dim_scale <dim> (<factor>, <order>)|
  respects the maximal and minimal extension of <dim>.
*)
let dim_scale dim (factor, order) =
  if lt_num factor num_zero then
    if order = dim.d_shrink_order
    then dim_shift_base dim (mult_num factor dim.d_shrink_factor)
    else dim
  else
    if order = dim.d_stretch_order
    then dim_shift_base dim (mult_num factor dim.d_stretch_factor)
    else dim
  
let dim_scale_upto dim (factor, order) =
  if lt_num factor num_zero then
    if order = dim.d_shrink_order
    then dim_shift_base_upto dim (mult_num factor dim.d_shrink_factor)
    else dim
  else
    if order = dim.d_stretch_order
    then dim_shift_base_upto dim (mult_num factor dim.d_stretch_factor)
    else dim
  
let xdim_select_order dim stretch_order shrink_order =
  let rec find order list =
    match list with
      | [] -> (num_zero, order)
      | (f, o) :: l -> if o = order then (f, order) else find order l in
  let (st_f, st_o) = find stretch_order dim.xd_stretch in
  let (sh_f, sh_o) = find shrink_order dim.xd_stretch in
    { d_base = dim.xd_base;
      d_stretch_factor = st_f;
      d_stretch_order = st_o;
      d_shrink_factor = sh_f;
      d_shrink_order = sh_o }

(*-----------------------------------------------------------------------*)
